Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/cnstrnts/skyblue.lha/SkyBlue/sky-blue.lisp

Lisp/Scheme | 1993-07-24 | 51KB | 1,426 lines

;;;-*- Package: :sky-blue; Syntax: Common-Lisp; Mode: Lisp -*-;

(in-package :sky-blue :nicknames '(:sb) :use '(:lisp))

(eval-when (load eval compile) (require :loop))

(export '(
      create-sb-constraint
      create-sb-method
      create-sb-variable

      add-set-slot-fn
      remove-set-slot-fn

      get-sb-constraint-slot
      set-sb-constraint-slot
      get-sb-variable-slot
      set-sb-variable-slot
      get-sb-method-slot
      get-sb-method-slot

      sb-constraint-p
      sb-method-p
      sb-variable-p

      get-sb-slot
      set-sb-slot
      sb-object-p

      cn-variables
      cn-strength
      cn-methods
      cn-selected-method
      cn-mark

      mt-code
      mt-outputs

      var-value
      var-constraints
      var-determined-by
      var-walk-strength
      var-mark
      var-valid

      sb-plan-p
      extract-plan
      sb-plan-valid
      execute-plan
      invalidate-plans-on-setting-method

      enforced
      do-method-output-vars
      do-selected-method-output-vars
      do-method-input-vars
      do-selected-method-input-vars
      do-consuming-constraints

      method-output-vars
      selected-method-output-vars
      method-input-vars
      selected-method-input-vars
      consuming-constraints

      add-constraint
      remove-constraint
      *sky-blue-backtracking-warning*
      *sky-blue-cycle-warning*

      *strength-keyword-list*
      *strength-list*
      *required-strength*
      *weakest-strength*
      get-strength
      get-strength-keyword
      weaker
      ))

;; ********************************************************************************
;;                       SkyBlue data structures
;; ********************************************************************************

;; ***** strengths: represented as keywords *****

(defvar *strength-keyword-list*
  (list :required :strong :medium :weak :s1 :s2 :s3 :s4 :s5 :s6 :s7 :weakest))

;; transfer between strength keywords and numbers.
;; For convenience, can give either form to either fn.

(defun get-strength (strength)
  (cond ((and (integerp strength)
          (nth strength *strength-keyword-list*))
     strength)
    ((member strength *strength-keyword-list*)
     (position strength *strength-keyword-list*))
    (t
     (error "get-strength: bad strength: ~S" strength))))

(defun get-strength-keyword (strength)
  (cond ((and (integerp strength)
          (nth strength *strength-keyword-list*))
     (nth strength *strength-keyword-list*))
    ((member strength *strength-keyword-list*)
     strength)
    (t
     (error "get-strength-keyword: bad strength: ~S" strength))))

(defmacro weaker (s1 s2) `(> ,s1 ,s2))

(defvar *strength-list*
    (loop for key in *strength-keyword-list*
    collect (get-strength key)))

(defvar *required-strength* (get-strength :required))
(defvar *weakest-strength* (get-strength :weakest))

;; ***** marks *****

(defvar *mark-counter* 0)

;; new-mark returns a new, unique mark.  new-mark will never return nil,
;; so we can use nil as a mark to "unmark" objects.
(defun new-mark ()
  (incf *mark-counter* 1)
  *mark-counter*)

;; ***** sky-blue object definitions *****

;; constraint representation:
;;
;;   field         | type      | description
;; ----------------+-----------+--------------------------------------------
;; variables       | set of    | the variables that this constraint references.
;;                 | variables |
;; strength        | strength  | this constraint's level in the constraint
;;                 |           |  hierarchy.
;; methods         | set of    | the potential methods for satisfying this
;;                 | methods   | constraint.
;; selected-method | method    | the method used to satisfy this constraint,
;;                 |           | nil if the constraint is not satisfied.
;;           |           | should only be manipulated by skyblue.
;; mark            | integer   | this constraint's mark value.
;; other-slots     | alist     | association list of other slot/value pairs
;; set-slot-fn     | fn(s)     | fn or list of fns to call before setting any slot

(defstruct (sb-Constraint
        (:print-function
         (lambda (cn str lvl)
           (declare (ignore lvl))
           (cond ((get-sb-slot cn :name)
              (format str "{cn-~A}" (get-sb-slot cn :name)))
             ((sb-constraint-strength cn)
              (format str "{cn~A}"
                  (get-strength-keyword (sb-constraint-strength cn))))
             (t (format str "{cn}")))))
        )
  variables
  strength
  methods
  selected-method
  mark
  other-slots
  set-slot-fn
  )

(defun get-sb-constraint-slot (obj slot)
  (case slot
    (:variables (sb-constraint-variables obj))
    (:strength (sb-constraint-strength obj))
    (:methods (sb-constraint-methods obj))
    (:selected-method (sb-constraint-selected-method obj))
    (:mark (sb-constraint-mark obj))
    (:set-slot-fn (sb-constraint-set-slot-fn obj))
    (t
     (getf (sb-constraint-other-slots obj) slot nil))))

(defmacro cn-variables (cn) `(sb-constraint-variables ,cn))
(defmacro cn-strength (cn) `(sb-constraint-strength ,cn))
(defmacro cn-methods (cn) `(sb-constraint-methods ,cn))
(defmacro cn-selected-method (cn) `(sb-constraint-selected-method ,cn))
(defmacro cn-mark (cn) `(sb-constraint-mark ,cn))

;; all slot-set forms call call-set-slot-fn

(defun set-sb-constraint-slot (cn slot val)
  (call-set-slot-fn (sb-constraint-set-slot-fn cn) cn slot val)
  (case slot
    (:variables (setf (sb-constraint-variables cn) val))
    (:strength (setf (sb-constraint-strength cn) val))
    (:methods (setf (sb-constraint-methods cn) val))
    (:selected-method (setf (sb-constraint-selected-method cn) val))
    (:mark (setf (sb-constraint-mark cn) val))
    (:set-slot-fn (setf (sb-constraint-set-slot-fn cn) val))
    (t
     (setf (getf (sb-constraint-other-slots cn) slot nil) val)))
  val)

(defsetf cn-strength (cn) (val)
  `(let ((cn ,cn)(val ,val))
     (call-set-slot-fn (sb-constraint-set-slot-fn cn) cn :strength val)
     (setf (sb-constraint-strength cn) val)))
(defsetf cn-variables (cn) (val)
  `(let ((cn ,cn)(val ,val))
     (call-set-slot-fn (sb-constraint-set-slot-fn cn) cn :variables val)
     (setf (sb-constraint-variables cn) val)))
(defsetf cn-methods (cn) (val)
  `(let ((cn ,cn)(val ,val))
     (call-set-slot-fn (sb-constraint-set-slot-fn cn) cn :methods val)
     (setf (sb-constraint-methods cn) val)))
(defsetf cn-selected-method (cn) (val)
  `(let ((cn ,cn)(val ,val))
     (call-set-slot-fn (sb-constraint-set-slot-fn cn) cn :selected-method val)
     (setf (sb-constraint-selected-method cn) val)))
(defsetf cn-mark (cn) (val)
  `(let ((cn ,cn)(val ,val))
     (call-set-slot-fn (sb-constraint-set-slot-fn cn) cn :mark val)
     (setf (sb-constraint-mark cn) val)))

(defun create-sb-constraint (&key (name nil)
                               (variables nil)
                               (strength :required)
                               (methods nil)
                               (selected-method nil)
                               (mark nil)
                   (set-slot-fn nil)
                               )
  (let ((cn (make-sb-constraint :strength (get-strength strength)
                                :methods methods
                                :variables variables
                                :selected-method selected-method
                                :mark mark
                :set-slot-fn set-slot-fn
                                :other-slots nil)))
    (when name (set-sb-slot cn :name name))
    cn))

;; methods:
;;   a method represents one possible procedure for satisfying a constraint.
;;   fields of a method representation are initialized at the constraint
;;   creation time and never modified.
;;
;;   field        | type      | description
;;   -------------+-----------+--------------------------------------------
;;   code         | procedure | the procedure to be called to execute this
;;                |           | method (passed the constraint whose selected
;;                |           | method this is).
;;   outputs      | list of vars | list of output vars for this method.
;; other-slots    | alist     | association list of other slot/value pairs
;;   set-slot-fn  |  fn(s)    | fn or list of fns to call before setting any slot

(defstruct (sb-Method
        (:print-function
         (lambda (mt str lvl)
           (declare (ignore lvl))
           (cond ((get-sb-slot mt :name)
              (format str "{mt-~A}" (get-sb-slot mt :name)))
             (t (format str "{mt}")))))
        )
  code
  outputs
  other-slots
  set-slot-fn
  )

(defun get-sb-method-slot (mt slot)
  (case slot
    (:code (sb-method-code mt))
    (:outputs (sb-method-outputs mt))
    (:set-slot-fn (sb-method-set-slot-fn mt))
    (t
     (getf (sb-method-other-slots mt) slot nil))))

(defmacro mt-code (mt) `(sb-method-code ,mt))
(defmacro mt-outputs (mt) `(sb-method-outputs ,mt))

(defun set-sb-method-slot (mt slot val)
  (call-set-slot-fn (sb-method-set-slot-fn mt) mt slot val)
  (case slot
    (:code (setf (sb-method-code mt) val))
    (:outputs (setf (sb-method-outputs mt) val))
    (:set-slot-fn (setf (sb-method-set-slot-fn mt) val))
    (t
     (setf (getf (sb-method-other-slots mt) slot nil) val))))

(defsetf mt-code (mt) (val)
  `(let ((mt ,mt)(val ,val))
     (call-set-slot-fn (sb-method-set-slot-fn mt) mt :code val)
     (setf (sb-method-code mt) val)))
(defsetf mt-outputs (mt) (val)
  `(let ((mt ,mt)(val ,val))
     (call-set-slot-fn (sb-method-set-slot-fn mt) mt :outputs val)
     (setf (sb-method-outputs mt) val)))

(defun create-sb-method (&key (name nil)
                  (code #'(lambda (cn) cn))
                  (outputs nil))
  (let ((mt (make-sb-method :code code
                :outputs outputs
                :other-slots nil)))
    (when name (set-sb-slot mt :name name))
    mt))

;; variables:
;;
;;   field        | type        | description
;;  --------------+-------------+--------------------------------------------
;;  value         | any         | value of the variable
;;  constraints   | set of      | all the constraints that reference this
;;                | constraints | variable.
;;  determined-by | constraint  | the constraint that determines this
;;                |             | variable's value.
;;  walk-strength | strength    | the walkabout strength of this variable.
;;  mark          | integer     | this variable's mark value.
;;  valid         | boolean     | true if this variable value is valid
;; other-slots    | alist       | association list of other slot/value pairs
;; set-slot-fn    | fn(s)       | fn or list of fns to call before setting any slot

(defstruct (sb-Variable
        (:print-function
         (lambda (var str lvl)
           (declare (ignore lvl))
           (cond ((get-sb-slot var :name)
              (format str "{var-~A}" (get-sb-slot var :name)))
             (t (format str "{var}")))))
        )
  constraints
  determined-by
  walk-strength
  mark
  valid
  value
  other-slots
  set-slot-fn
  )

(defun get-sb-variable-slot (var slot)
  (case slot
    (:value (sb-variable-value var))
    (:constraints (sb-variable-constraints var))
    (:determined-by (sb-variable-determined-by var))
    (:walk-strength (sb-variable-walk-strength var))
    (:mark (sb-variable-mark var))
    (:valid (sb-variable-valid var))
    (:set-slot-fn (sb-variable-set-slot-fn var))
    (t
     (getf (sb-variable-other-slots var) slot nil))))

(defmacro var-value (var) `(sb-variable-value ,var))
(defmacro var-constraints (var) `(sb-variable-constraints ,var))
(defmacro var-determined-by (var) `(sb-variable-determined-by ,var))
(defmacro var-walk-strength (var) `(sb-variable-walk-strength ,var))
(defmacro var-mark (var) `(sb-variable-mark ,var))
(defmacro var-valid (var) `(sb-variable-valid ,var))

(defun set-sb-variable-slot (var slot val)
  (call-set-slot-fn (sb-variable-set-slot-fn var) var slot val)
  (case slot
    (:value (setf (sb-variable-value var) val))
    (:constraints (setf (sb-variable-constraints var) val))
    (:determined-by (setf (sb-variable-determined-by var) val))
    (:walk-strength (setf (sb-variable-walk-strength var) val))
    (:mark (setf (sb-variable-mark var) val))
    (:valid (setf (sb-variable-valid var) val))
    (:set-slot-fn (setf (sb-variable-set-slot-fn var) val))
    (t
     (setf (getf (sb-variable-other-slots var) slot nil) val))))

(defsetf var-value (var) (val) `(set-sb-variable-slot ,var :value ,val))
(defsetf var-constraints (var) (val) `(set-sb-variable-slot ,var :constraints ,val))
(defsetf var-determined-by (var) (val) `(set-sb-variable-slot ,var :determined-by ,val))
(defsetf var-walk-strength (var) (val) `(set-sb-variable-slot ,var :walk-strength ,val))
(defsetf var-mark (var) (val) `(set-sb-variable-slot ,var :mark ,val))
(defsetf var-valid (var) (val) `(set-sb-variable-slot ,var :valid ,val))

(defun create-sb-variable (&key (name nil)
                (value nil)
                (constraints nil)
                (determined-by nil)
                (walk-strength :weakest)
                (mark 0)
                (valid t)
                (set-slot-fn nil)
                )
  (let ((var (make-sb-variable :value value
                   :constraints constraints
                   :determined-by determined-by
                   :walk-strength (get-strength walk-strength)
                   :mark mark
                   :valid valid
                   :set-slot-fn set-slot-fn
                   :other-slots nil)))
    (when name (set-sb-slot var :name name))
    var))

;; ***** generic sb object fns *****

(defun get-sb-slot (obj slot)
  (etypecase obj
    (sb-constraint (get-sb-constraint-slot obj slot))
    (sb-variable (get-sb-variable-slot obj slot))
    (sb-method (get-sb-method-slot obj slot))))

(defun set-sb-slot (obj slot val)
  (etypecase obj
    (sb-constraint (set-sb-constraint-slot obj slot val))
    (sb-variable (set-sb-variable-slot obj slot val))
    (sb-method (set-sb-method-slot obj slot val))))

(defun sb-object-p (obj)
  (or (sb-constraint-p obj)
      (sb-variable-p obj)
      (sb-method-p obj)))

;; ***** set-slot-fn handling *****

(defun call-set-slot-fn (fns obj slot val)
  (cond ((null fns)
     nil)
    ((listp fns)
     (loop for fn in fns do (call-set-slot-fn fn obj slot val)))
    (t
     (funcall fns obj slot val))))

(defun add-set-slot-fn (obj fn)
  (let* ((curr (get-sb-slot obj :set-slot-fn))
     (curr-list (if (listp curr) curr (list curr))))
    (unless (member fn curr-list)
      (set-sb-slot obj :set-slot-fn (cons fn curr)))
    ))

(defun remove-set-slot-fn (obj fn)
  (let* ((curr (get-sb-slot obj :set-slot-fn))
     (curr-list (if (listp curr) curr (list curr))))
    (set-sb-slot obj :set-slot-fn (remove fn curr-list))
    ))

;; useful macros

(defmacro enforced (c)
  `(cn-selected-method ,c))

(defmacro do-method-output-vars ((var-var cn-form mt-form) . body)
  (declare (ignore cn-form))
  `(loop for ,var-var in (MT-outputs ,mt-form) do
     (progn ,@body)))

(defmacro do-selected-method-output-vars ((var-var cn-form) . body)
  `(loop for ,var-var in (MT-outputs (cn-selected-method ,cn-form))
       do (progn ,@body)))

(defmacro do-method-input-vars ((var-var cn-form mt-form) . body)
  (let ((cn-var (gentemp))
    (mt-var (gentemp))
    (outputs-var (gentemp)))
    `(let* ((,cn-var ,cn-form)
        (,mt-var ,mt-form)
        (,outputs-var (mt-outputs ,mt-var)))
       (loop for ,var-var in (cn-variables ,cn-var)
       do (when (not (member ,var-var ,outputs-var))
        ,@body)))
    ))

(defmacro do-selected-method-input-vars ((var-var cn-form) . body)
  (let ((cn-var (gentemp))
    (mt-var (gentemp)))
    `(let* ((,cn-var ,cn-form)
        (,mt-var (cn-selected-method ,cn-var)))
       (do-method-input-vars (,var-var ,cn-var ,mt-var) ,@body))
    ))

(defmacro do-consuming-constraints ((constraint-var var-form) . body)
  (let ((var-var (gentemp))
    (var-determined-by-var (gentemp)))
    `(let* ((,var-var ,var-form)
        (,var-determined-by-var (var-determined-by ,var-var)))
       (loop for ,constraint-var in (var-constraints ,var-form)
       do (when (and (not (eq ,constraint-var ,var-determined-by-var))
             (enforced ,constraint-var))
        ,@body)))
    ))

;; inefficient fns for consing up lists of input, output vars
;; use methods above for efficiency

(defun method-output-vars (cn mt)
  (declare (ignore cn))
  (mt-outputs mt))

(defun selected-method-output-vars (cn)
  (MT-outputs (cn-selected-method cn)))

(defun method-input-vars (cn mt)
  (loop for var in (cn-variables cn)
      when (not (member var (mt-outputs mt)))
      collect var))

(defun selected-method-input-vars (cn)
  (method-input-vars cn (cn-selected-method cn)))

(defun consuming-constraints (v)
  (loop for cn in (var-constraints v)
        when (and (enforced cn)
                  (not (eql cn (var-determined-by v))))
        collect cn))


;; ***** stack objects *****

(defstruct (sb-stack
        (:conc-name "SB-STACK-")
        (:print-function
         (lambda (stack str lvl)
           (declare (ignore lvl))
           (sb-stack-print stack str)))
        )
  size
  vector
  max-vector-size
  overflow)

(defun sb-stack-create (max-vector-size)
  (make-sb-stack :max-vector-size max-vector-size
         :vector (make-array (list max-vector-size))
         :size 0
         :overflow nil))

(defun sb-stack-clear (stack)
  (setf (sb-stack-size stack) 0)
  stack)

(defun sb-stack-push (stack elt)
  (cond ((< (sb-stack-size stack) (sb-stack-max-vector-size stack))
     (setf (aref (sb-stack-vector stack) (sb-stack-size stack)) elt))
    (t
     (push elt (sb-stack-overflow stack))))
  (incf (sb-stack-size stack) 1)
  elt)

(defun sb-stack-pop (stack)
  (incf (sb-stack-size stack) -1)
  (cond ((< (sb-stack-size stack) 0)
     (cerror "return nil" "sb-stack-pop: stack empty")
     (setf (sb-stack-size stack) 0)
     nil)
    ((< (sb-stack-size stack) (sb-stack-max-vector-size stack))
     (aref (sb-stack-vector stack) (sb-stack-size stack)))
    (t
     (pop (sb-stack-overflow stack)))))

(defun sb-stack-empty (stack)
  (zerop (sb-stack-size stack)))

;; loops over all elts in the stack, without removing any.
(defmacro do-sb-stack-elts ((var-var stack-form) . body)
  (let ((stack-var (gentemp))
    (vector-var (gentemp))
    (elt-var (gentemp))
    (overflow-var (gentemp))
    (vector-size-var (gentemp)))
    `(let* ((,stack-var ,stack-form)
        (,vector-var (sb-stack-vector ,stack-var))
        (,overflow-var (sb-stack-overflow ,stack-var))
        (,vector-size-var (sb-stack-max-vector-size ,stack-var)))
       (loop for ,elt-var from (1- (sb-stack-size ,stack-var)) downto 0 do
         (let ((,var-var (cond ((< ,elt-var ,vector-size-var)
                    (aref ,vector-var ,elt-var))
                   (t (pop ,overflow-var)))))
           ,@body)))
    ))

(defun sb-stack-member (stack obj)
  (do-sb-stack-elts (elt stack)
    (when (eql elt obj)
      (return-from sb-stack-member t)))
  nil)

(defun sb-stack-print (stack str)
  (format str "{stack(~S):" (sb-stack-size stack))
  (do-sb-stack-elts (elt stack) (format str " ~S" elt))
  (format str "}"))

;; ***** stack of cns sorted by strength *****

(defstruct (sb-cns-set
        (:conc-name "SB-CNS-SET-")
        (:print-function
         (lambda (stack str lvl)
           (declare (ignore lvl))
           (sb-cns-set-print stack str)))
        )
  size
  num-strengths
  cns-stacks)

(defun sb-cns-set-create (max-cns)
  (let* ((num-strengths (length *strength-list*))
     (cns-per-strength (truncate max-cns num-strengths))
     (strength-cns-stacks (make-array (list num-strengths))))
    (loop for index from 0 to (1- num-strengths) do
      (setf (aref strength-cns-stacks index)
        (sb-stack-create cns-per-strength)))
    (make-sb-cns-set :size 0
             :cns-stacks strength-cns-stacks
             :num-strengths num-strengths)
    ))

(defun sb-cns-set-clear (stack)
  (let ((stacks (sb-cns-set-cns-stacks stack)))
    (loop for index from 0 to (1- (sb-cns-set-num-strengths stack))
    do (sb-stack-clear (aref stacks index)))
    (setf (sb-cns-set-size stack) 0)
    stack))

(defun sb-cns-set-add (stack cn)
  (let* ((stacks (sb-cns-set-cns-stacks stack))
     (cn-stack (aref stacks (CN-strength cn))))
    (unless (sb-stack-member cn-stack cn)
      (sb-stack-push cn-stack cn)
      (incf (sb-cns-set-size stack) 1))
    cn))

(defun sb-cns-set-pop-strongest (stack)
  (incf (sb-cns-set-size stack) -1)
  (cond ((< (sb-stack-size stack) 0)
     (cerror "return nil" "sb-cns-set-pop: stack empty")
     (sb-cns-set-clear stack)
     nil)
    (t
     (let ((stacks (sb-cns-set-cns-stacks stack)))
       (loop for index from 0 to (1- (sb-cns-set-num-strengths stack))
           do (let ((cn-stack (aref stacks index)))
            (when (not (sb-stack-empty cn-stack))
              (return (sb-stack-pop cn-stack))))
           finally (cerror "return nil" "sb-cns-set-pop: all substacks empty")))
     )))

(defun sb-cns-set-empty (stack)
  (zerop (sb-cns-set-size stack)))

(defun sb-cns-set-print (stack str)
  (format str "{cns-set(~S):" (sb-cns-set-size stack))
  (let ((stacks (sb-cns-set-cns-stacks stack)))
    (loop for index from 0 to (1- (sb-cns-set-num-strengths stack))
    do (let ((cn-stack (aref stacks index)))
         (when (not (sb-stack-empty cn-stack))
           (format str " {")
           (do-sb-stack-elts (elt cn-stack) (format str "~S " elt))
           (format str "}")))))
  (format str "}"))


;; loops over all elts in the set, from strongest-to-weakest,
;; without removing any.
(defmacro do-sb-cns-set-elts ((var-var set-form) . body)
  (let ((set-var (gentemp))
    (stacks-var (gentemp))
    (index-var (gentemp))
    (cn-stack-var (gentemp)))
    `(let* ((,set-var ,set-form)
        (,stacks-var (sb-cns-set-cns-stacks ,set-var)))
       (loop for ,index-var from 0 to (1- (sb-cns-set-num-strengths ,set-var))
       do (let ((,cn-stack-var (aref ,stacks-var ,index-var)))
        (when (not (sb-stack-empty ,cn-stack-var))
          (do-sb-stack-elts (,var-var ,cn-stack-var) ,@body)))))
    ))

;; ***** plans *****

(defstruct (sb-plan
        (:conc-name "SB-PLAN-")
        (:print-function
         (lambda (plan str lvl)
           (declare (ignore lvl))
           (sb-plan-print plan str)))
        )
  good-cns
  bad-cns
  root-cns
  valid
  )

(defun sb-plan-print (plan str)
  (format str "{~Aplan:~Sgood,~Sbad,~Sroot}"
      (if (sb-plan-valid plan) "valid-" "invalid-")
      (length (sb-plan-good-cns plan))
      (length (sb-plan-bad-cns plan))
      (length (sb-plan-root-cns plan))))

;; ***** interlock to prevent accidental recursive calls to skyblue *****
;; add-constraint and remove-constraint should never be called recursively
;; (for example: from within a constraint method).  This signals a
;; continuable error if this is done.

(defvar *sky-blue-running* nil)

(defmacro with-sky-blue-recursion-check (&rest forms)
  `(cond (*sky-blue-running*
      (cerror "add-constraint or remove-constraint ignored"
          "sky-blue add-constraint or remove-constraint called recursively!")
      )
     (t
      (unwind-protect
          (progn
        (setq *sky-blue-running* t)
        (progn ,@forms))
        (setq *sky-blue-running* nil))
      )))

;; ********************************************************************************
;;                       SkyBlue algorithm
;; ********************************************************************************

;; Sky-Blue global stacks: rather than passing these stacks between the
;; different functions, these are saved as global variables.

;; stack of unenforced cns that we want to try enforcing, sorted by
;; strength from strongest to weakest
(defvar *unenforced-cns-stack* (sb-cns-set-create 200))

;; stack of redetermined variables that we will trace downstream from to
;; find unenforced cns.
(defvar *redetermined-vars-stack* (sb-stack-create 100))

;; stack of newly-undetermined vars and newly-added cns.  To enforce the
;; cns in the current method graph, we will trace downstream from these
;; vars and cns, evaling methods.
(defvar *exec-roots-stack* (sb-stack-create 100))

;; ***** Sky-Blue Entry Points *****

(defun add-constraint (cn)
  (with-sky-blue-recursion-check
      ;; clear stacks
      (sb-cns-set-clear *unenforced-cns-stack*)
    (sb-stack-clear *exec-roots-stack*)
    ;; initialize constraint fields, and register with variables
    (setf (CN-selected-method cn) nil)
    (setf (CN-mark cn) nil)
    (loop for v in (CN-variables cn) do
      (push cn (VAR-constraints v)))
    ;; find the method graph to enforce the new cn (if possible),
    ;; collecting any exec-roots.
    (sb-cns-set-add *unenforced-cns-stack* cn)
    (update-method-graph)
    ;; enforce method graph cns by evaluating cn methods.
    (exec-from-roots)
    )
  cn)

(defun remove-constraint (cn)
  (with-sky-blue-recursion-check
      ;; unregister cn from variables
      (loop for v in (CN-variables cn) do
        (setf (VAR-constraints v)
              (remove cn (VAR-constraints v))))
    (when (enforced cn)
      ;; clear stacks
      (sb-cns-set-clear *unenforced-cns-stack*)
      (sb-stack-clear *redetermined-vars-stack*)
      (sb-stack-clear *exec-roots-stack*)
      ;; loop over current outputs of cn
      (do-selected-method-output-vars (var cn)
    ;; un-determine current method's output vars
    (setf (VAR-determined-by var) nil)
    (setf (VAR-walk-strength var) *weakest-strength*)
    ;; collect output vars on redetermined vars stack
    (sb-stack-push *redetermined-vars-stack* var)
    ;; also collect output vars as possible exec roots
    (sb-stack-push *exec-roots-stack* var)
    )
      ;; un-enforce cn
      (setf (CN-selected-method cn) nil)
      ;; propagate walkstrength from newly undetermined vars
      (propagate-walkstrength *redetermined-vars-stack*)
      ;; collect all unenforced cns downstream of undetermined vars
      ;; that have the same or weaker strength than the removed cn
      (collect-unenforced (CN-strength cn) t)
      ;; find method graph to enforce the collected unenforced cns
      (update-method-graph)
      ;; enforce method graph cns by evaluating cn methods.
      (exec-from-roots)
      )
    )
    cn)

;; update-method-graph modifies the current method graph to include the
;; constraints in *unenforced-cns-stack*, maintaining it as a
;; locally-graph-better method graph.  Each time a cn is enforced, other
;; unenforced cns that might be enforcable may be found, so these are added
;; to the stack.  As a heuristic, the stack is kept in order of cn
;; strength, and we always try enforcing the strongest unenforced cn first.
;; This fn also updates *exec-roots-stack* by adding any cns were
;; sucessfully enforced, as well as any newly-undetermined vars that should
;; now be validated.  *redetermined-vars-stack* is a stack that is used for
;; temporary storage of a list of undetermined variables.
(defun update-method-graph ()
  (let* (ok cn)
    (loop until (sb-cns-set-empty *unenforced-cns-stack*) do
      (setq cn (sb-cns-set-pop-strongest *unenforced-cns-stack*))
      ;; try building mvine, collecting newly-undetermined vars
      (sb-stack-clear *redetermined-vars-stack*)
      (setq ok (build-mvine cn))
      (when ok
        ;; we found an mvine!
        ;; prop walkstrengths down mvine, and from newly undetermined vars
        (propagate-walkstrength (list cn *redetermined-vars-stack*))
        ;; collect any cns strictly weaker than cn that may now be enforcible
        (collect-unenforced (CN-strength cn) nil)
        ;; add all new undetermined vars and newly-added cn to exec-roots
        (do-sb-stack-elts (var *redetermined-vars-stack*)
          (when (null (VAR-determined-by var))
        (sb-stack-push *exec-roots-stack* var)))
        (sb-stack-push *exec-roots-stack* cn)
        ))
    ))

;; ***** building method vines *****

;; build-mvine is one of a set of mutually-recursive fns that perform a
;; backtracking search for a mutually-consistant method assignments for the
;; specified constraint.  The "mvine" that is being built is a method
;; vine rooted at the cn originially used to start this process, which had
;; strength root-strength.  The leaves of the mvine are cns weaker than
;; this strength, that are left unenforced (with no method selected).  It
;; is also possible that a leaf may loop back to a lower part of the mvine:
;; this is acceptable.  These functions perform the search by marking cns
;; and vars with the specified mark: only when a complete mvine is found
;; are the selected methods changed to reflect this.  These functions all
;; return t iff a way was found to enforce the cn, nil otherwise.  All of
;; the functions add redetermined vars to the stack
;; *redetermined-vars-stack*.

(defvar *mvine-cns-stack* (sb-stack-create 30))

(defun build-mvine (cn)
  (sb-stack-clear *mvine-cns-stack*)
  ;; try to build mvine starting with enforcing root cn as a branch
  (mvine-enforce-cn cn (cn-strength cn) (new-mark)))

(defun mvine-grow (root-strength done-mark)
  (if (sb-stack-empty *mvine-cns-stack*)
      ;; no more cns, we have found a complete prop path!
      t
    ;; process next cn
    (let* (cn ok)
      (setq cn (sb-stack-pop *mvine-cns-stack*))
      (cond ((eql done-mark (CN-mark cn))
         ;; this cn has already been marked: process other cns
         (setq ok (mvine-grow root-strength done-mark)))
        ((weaker (CN-strength cn) root-strength)
         ;; this cn is weaker than the root cn: revoke it
         (setq ok (mvine-revoke-cn cn root-strength done-mark)))
        (t
         ;; try to find a method for this cn
         (setq ok (mvine-enforce-cn cn root-strength done-mark)))
        )
      ;; if we are backtracking, must restore *mvine-cns-stack*
      (when (not ok)
    (sb-stack-push *mvine-cns-stack* cn))
      ok)
    ))

(defun mvine-revoke-cn (cn root-strength done-mark)
  (let* ((old-mt (CN-selected-method cn))
     ok)
    ;; mark this cn.  we will process it by revoking it.
    (setf (CN-mark cn) done-mark)
    ;; try building rest of mvine
    (setq ok (mvine-grow root-strength done-mark))
    (cond (ok
       ;; we found entire mvine!
       ;; undetermine unmarked old-mt outputs,
       ;; and save on *redetermined-vars-stack*
       (loop for var in (MT-outputs old-mt)
           when (not (eql done-mark (VAR-mark var))) do
         ;; unmarked vars must be newly undetermined.
         ;; reset determined-by and walkstrength of newly undetermined vars
         (setf (VAR-determined-by var) nil)
         (setf (VAR-walk-strength var) *weakest-strength*)
         (sb-stack-push *redetermined-vars-stack* var)
         )
       ;; set selected-method for this cn
       (setf (CN-selected-method cn) nil)
       t)
      (t
       ;; no mvine found: we are backtracking.
       ;; there is no other choice for this cn, so just un-mark cn
       ;; and continue backtracking.
       (setf (CN-mark cn) nil)
       nil))
    ))

(defun mvine-enforce-cn (cn root-strength done-mark)
  (let* ((old-mt (CN-selected-method cn))
     ;; note: old-mt=nil if cn is the unenforced mvine root
     (old-outputs (if old-mt (MT-outputs old-mt) nil))
     ok)
    ;; mark this constraint: we will try to make it into a branch
    (setf (CN-mark cn) done-mark)
    ;; try each possible method: returning if one is found that allows
    ;; mvine to be built
    (loop for mt in (CN-methods cn)
    when (possible-method mt root-strength done-mark old-outputs)
    do
      (let* ((next-cns-cnt 0))
        ;; add constraints determining this mt's outputs onto stack
        ;; (and count them so we know how many to pop during backtracking)
        (loop for var in (MT-outputs mt) do
          (let ((next-cn (VAR-determined-by var)))
            (when (and next-cn (not (eql cn next-cn)))
              (sb-stack-push *mvine-cns-stack* next-cn)
              (setq next-cns-cnt (+ next-cns-cnt 1)))))
        ;; let's try to build the mvine with this cn/mt.
        ;; mark the output vars of the method
        (loop for var in (MT-outputs mt) do
          (setf (VAR-mark var) done-mark))
        ;; try building rest of mvine
        (setq ok (mvine-grow root-strength done-mark))
        (cond (ok
           ;; we found entire mvine!
           ;; undetermine unmarked output vars of old mt,
           ;; and save on *redetermined-vars-stack*
           (loop for var in old-outputs
               when (not (eql done-mark (VAR-mark var))) do
             ;; unmarked vars must be newly undetermined.
             ;; reset determined-by and walkstrength of newly undetermined vars
             (setf (VAR-determined-by var) nil)
             (setf (VAR-walk-strength var) *weakest-strength*)
             (sb-stack-push *redetermined-vars-stack* var)
             )
           ;; set selected method for this cn, and ptrs in new outputs
           ;; and save on *redetermined-vars-stack*
           (setf (CN-selected-method cn) mt)
           (loop for var in (MT-outputs mt) do
             (setf (VAR-determined-by var) cn)
             (sb-stack-push *redetermined-vars-stack* var)
             )
           ;; return t without trying any more methods
           (return-from mvine-enforce-cn t))
          (t
           ;; no mvine found: try next method
           ;; "undo" current method choice: unmark method outputs
           (loop for var in (MT-outputs mt) do
             (setf (VAR-mark var) nil))
           ;; pop constraints we added above
           (loop for cnt from 1 to next-cns-cnt do
             (sb-stack-pop *mvine-cns-stack*))
           ))
        ;; unless we found a soln: continue loop to try next method
        ))
    ;; loop finished: no more methods to try: unmark cn and backtrack
    (setf (CN-mark cn) nil)
    ;; signal backtracking point (unless this is root cn)
    (unless (null old-mt)
      (signal-backtracking cn))
    nil))

(defvar *sky-blue-backtracking-warning* nil)

;; this is called to print a warning message when the mvine-enforce-cn fn
;; backtracks because cn cannot be extended into a complete mvine.
;; This message can be prevented by setting *sky-blue-backtracking-warning*
;; to nil.
(defun signal-backtracking (cn)
  (when *sky-blue-backtracking-warning*
    (format t "~&Sky-blue: backtracking at ~S~%" cn)))

;; a method is only possible if both: (1) all its outputs are unmarked
;; (i.e. they aren't being used yet in the mvine) (2) every output
;; walkstrength is weaker than the cn's strength (except for vars that are
;; current outputs)
(defun possible-method (mt root-strength mark current-outputs)
  (loop for var in (MT-outputs mt) never
    (or
     ;; if an output var is marked, we can't use this method
     (eql mark (VAR-mark var))
     ;; if an output var is too strong, and is not currently
     ;; determined by the cn, we can't use this method
     (and (not (weaker (VAR-walk-strength var) root-strength))
          (not (member var current-outputs)))
     )
    ))

;; ***** propagating walkabout strengths *****

;; propagate walkstrengths downstream from the given cns and vars.  Cycles
;; are broken by inserting the most conservative walkstrength (weakest).

(defvar *propagate-walkstrength-stack* (sb-stack-create 100))

(defun propagate-walkstrength (roots)
  (let* ((prop-mark (new-mark))
     cn)
    ;; mark all cns we will be processing, and collect ordered pplan
    (sb-stack-clear *propagate-walkstrength-stack*)
    (pplan-add *propagate-walkstrength-stack* roots prop-mark)
    ;; scan through pplan
    (loop until (sb-stack-empty *propagate-walkstrength-stack*) do
      (setq cn (sb-stack-pop *propagate-walkstrength-stack*))
      (when (eql (CN-mark cn) prop-mark)
        (cond ((any-immediate-upstream-cns-marked cn prop-mark)
           ;; Some of this cn's upstream cns have not been processed: there
           ;; must be a cycle.  Handle it, possibly unmarking other cns in
           ;; the cycle, and calculating their walkstrengths.
           (propagate-walkstrength-cycle cn prop-mark)
           )
          (t
           ;; cn is not in a cycle: compute walkstrengths and mark it done
           (do-selected-method-output-vars (var cn)
             (setf (VAR-walk-strength var) (compute-walkabout cn var)))
           (setf (CN-mark cn) nil)
           ))
        ))
    ))

;; cn is in a cycle: break the cycle by setting any upstream
;; vars determined by the unprocessed cns to have :weakest
;; walkabout strength.  (the most conservative choice)
(defun propagate-walkstrength-cycle (cn prop-mark)
  (do-selected-method-input-vars (var cn)
    (let ((upstream-cn (VAR-determined-by var)))
      (when (and upstream-cn
         (eql prop-mark (CN-mark upstream-cn)))
    (setf (VAR-walk-strength var) *weakest-strength*))))
  ;; compute walkstrengths for cn, and mark it done
  (do-selected-method-output-vars (var cn)
    (setf (VAR-walk-strength var) (compute-walkabout cn var)))
  (setf (CN-mark cn) nil)
  )

;; any-immediate-upstream-cns-unmarked returns t iff none of the cns
;; determining the inputs of cn are marked with the given mark
(defun any-immediate-upstream-cns-marked (cn mark)
  (do-selected-method-input-vars (var cn)
    (let ((upstream-cn (VAR-determined-by var)))
      (when (and upstream-cn
         (eql mark (CN-mark upstream-cn)))
    (return-from any-immediate-upstream-cns-marked t))
      ))
  ;; none of the cns are marked: return nil
  nil)


;; compute-walkabout calculates the walkabout strength of the variable var
;; which is currently a selected output variable of the constraint cn.
;; This value is a lower bound on the strength a cn would need to have to
;; set this variable (causing this cn to change its selected mt).  Note:
;; different output vars may have different walkstrengths, since the cn may
;; have different sets of possible mts that don't set each var.  Note: have
;; to handle the case where some method's output vars is a subset of other
;; method's output vars.  Normally, one wouldn't define such a cn, but it
;; is possible to get this in Multi-Garnet with indirect var paths.
(defun compute-walkabout (cn var)
  (let* ((min-strength (CN-strength cn))
         (selected-method (CN-selected-method cn))
         (selected-out-vars (MT-outputs selected-method)))
    (loop for mt in (CN-methods cn)
          unless (eql mt selected-method)
          do
          (let ((out-vars (MT-outputs mt))
                (max-strength *weakest-strength*))
            (when (not (member var out-vars))
              ;; mt doesn't output to var, so this is a possible alternative
              ;; mt for this cn.  Find max output var walkstrength for this
              ;; mt, ignoring vars set by currently selected mt
              (loop for out-var in out-vars
          when (and (weaker max-strength (VAR-walk-strength out-var))
                (not (member out-var selected-out-vars)))
          do (setf max-strength (VAR-walk-strength out-var)))
              ;; note: final max-strength will be :weakest if there is a mt
              ;; with outputs that are a subset of the selected method
              (when (weaker max-strength min-strength)
                (setf min-strength max-strength)))
            ))
    min-strength))

;; ***** collect unenforced constraints *****

;; collect-unenforced traces downstream from all of the vars in
;; *redetermined-vars-stack*, adding to *unenforced-cns-stack* any
;; unenforced cns that could possibly output to these vars or downstream
;; vars.  If collect-equal-p is nil, this only collects cns strictly weaker
;; than collection-strength.  If collect-equal-p is non-nil, this collects
;; cns weaker than or with the same strength as collection-strength.
(defun collect-unenforced (collection-strength collect-equal-p)
  (let ((done-mark (new-mark)))
    (do-sb-stack-elts (var *redetermined-vars-stack*)
      (collect-unenforced-mark var collection-strength collect-equal-p done-mark))
    ))

(defun collect-unenforced-mark (var collection-strength collect-equal-p done-mark)
  (loop for cn in (VAR-constraints var)
      unless (or
          ;; if cn determines var, ignore
          (eql cn (VAR-determined-by var))
          ;; if we've already processed this cn, ignore it
          (eql done-mark (CN-mark cn))
          )
      do
    ;; we will process this cn now: mark it
    (setf (CN-mark cn) done-mark)
    (cond ((enforced cn)
           ;; cn is an enforced cn that consumes var:
           ;; collect cns downstream of cn's outputs
           (do-selected-method-output-vars (out-var cn)
         (collect-unenforced-mark out-var collection-strength
                      collect-equal-p done-mark))
           )
          ((or (weaker (CN-strength cn) collection-strength)
           (and collect-equal-p (eql (CN-strength cn) collection-strength)))
           ;; cn is an unenforced cn that is weak enough to collect
           (sb-cns-set-add *unenforced-cns-stack* cn)
           ))
    ))

;; ***** executing methods *****

(defvar *exec-pplan-stack* (sb-stack-create 100))

;; this fn takes the newly-undetermined vars and newly-added cns on
;; *exec-roots-stack* and tries to execute methods to enforce the cns in
;; the method graph.  if there are no cycles, this will validate all of
;; the vars.
(defun exec-from-roots ()
  (let* ((prop-mark (new-mark))
     cn)
    ;; mark all cns we will be processing, and collect ordered pplan
    (sb-stack-clear *exec-pplan-stack*)
    (do-sb-stack-elts (elt *exec-roots-stack*)
      (cond ((sb-constraint-p elt)
         (pplan-add *exec-pplan-stack* elt prop-mark))
        ((and (sb-variable-p elt)
          (null (VAR-determined-by elt))
          (not (VAR-valid elt)))
         ;; only need to exec-from-root of var if it is an undetermined
         ;; var being changed from non-valid to valid
         (pplan-add *exec-pplan-stack* elt prop-mark)
         ;; validate all undetermined vars
         (setf (VAR-valid elt) t)
         ))
      )
    ;; scan through pplan
    (loop until (sb-stack-empty *exec-pplan-stack*) do
      (setq cn (sb-stack-pop *exec-pplan-stack*))
      (cond ((not (eql prop-mark (CN-mark cn)))
         ;; this cn has already been processed: ignore
         nil)
        ((any-immediate-upstream-cns-marked cn prop-mark)
         ;; Some of this cn's upstream cns have not been processed:
         ;; there must be a cycle.  Call fn to handle cycle: this
         ;; fn may mark other cns as done.
         (exec-from-cycle cn prop-mark)
         )
        (t
         ;; All of this cn's upstream cns have been processed, so we
         ;; can now process this one and mark it done
         (execute-propagate-valid cn)
         (setf (CN-mark cn) nil)
         )
        ))
    ))

;; executes the selected method of cn if all of its inputs are valid.  In
;; any case, it propagate the valid flag to the outputs.
(defun execute-propagate-valid (cn)
  (let ((inputs-valid (block valid-block
            (do-selected-method-input-vars (var cn)
              (when (not (VAR-valid var))
                (return-from valid-block nil)))
            t)))
    (when inputs-valid
      (execute-selected-method cn))
    (do-selected-method-output-vars (var cn)
      (setf (VAR-valid var) inputs-valid))
    ))

(defun execute-selected-method (cn)
  (funcall (MT-code (CN-selected-method cn)) cn))

(defvar *sky-blue-cycle-solver-fns* nil)

;; handle cycle by trying a series of cycle solvers.  If one of the solvers
;; can find a solution, install it in the cycle variables.  If none of the
;; solvers can find a solution, invalidate the output vars of all cns in
;; the cycle (and downstream of it).
(defun exec-from-cycle (cn prop-mark)
  (let* ((cycle-cns (collect-cns-in-cycle (list cn) nil prop-mark)))
    ;; if any of the cycle input vars (input vars to any of
    ;; the cns in the cycle that are not set by other cycle cns)
    ;; are invalid, return without trying to solve the cycle.
    (loop for cn in cycle-cns do
      (do-selected-method-input-vars (var cn)
        (when (and (not (VAR-valid var))
               (not (member (VAR-determined-by var) cycle-cns)))
          ;; mark cn and downstream cns as done, and all outputs invalid
          (unmark-invalidate-downstream cn prop-mark)
          ;; and return without trying to solve cycle
          (return-from exec-from-cycle nil))
        ))
   ;; print warning
   (signal-cycle cycle-cns)
   ;; try cycle solvers
   (loop for solver-fn in *sky-blue-cycle-solver-fns*
       when
     ;; Call solver-fn to try solving cycle.  If it can solve the
     ;; cycle, it must set all of the var values of vars set by cycle
     ;; cns, and return t.  If it cannot solve the cycle, it must not
     ;; change anything, and return nil.
     (funcall solver-fn cycle-cns)
       do
     ;; This solver fn has succeeded.  Clear marks in cycle cns, so we
     ;; won't process them, and set var-valid for cn outputs
     (loop for cn in cycle-cns do
           (setf (CN-mark cn) nil)
           (do-selected-method-output-vars (var cn)
         (setf (VAR-valid var) t)))
     ;; We don't need to try any more cycle solvers
     (return-from exec-from-cycle nil))
   ;; None of the cycle solvers were sucessful.  Mark cn and
   ;; downstream cns as done, and all outputs invalid
   (unmark-invalidate-downstream cn prop-mark)
   ))

;; return a list of all cns upstream of the cns in roots that have not been
;; processed (i.e., cn-mark is not equal to prop-mark).  When called with
;; the cycle cn found in exec-from-cycle, this returns all of the cns in
;; the cycle.
(defun collect-cns-in-cycle (roots collected prop-mark)
  (let* ((cn (car roots))
     (next-roots (cdr roots)))
    (cond ((null roots) collected)
      ((not (equal prop-mark (CN-mark cn)))
       (collect-cns-in-cycle next-roots collected prop-mark))
      ((member cn collected)
       (collect-cns-in-cycle next-roots collected prop-mark))
      (t
       (do-selected-method-input-vars (var cn)
         (when (VAR-determined-by var)
           (push (VAR-determined-by var) next-roots)))
       (collect-cns-in-cycle
        next-roots (cons cn collected) prop-mark)
       ))
    ))

(defvar *sky-blue-cycle-warning* nil)

(defun signal-cycle (cns)
  (when *sky-blue-cycle-warning*
    (let* ((*print-length* 5))
      (declare (special *print-length*))
      (format t "~&Sky-blue cycle: ~S~%" cns))
    ))

(defun linear-eqn-cycle-solver (cns)
  (let* ((cycle-vars (loop for cn in cns
             append (selected-method-output-vars cn)))
     (eqns (loop for cn in cns collect
             (let* ((eqn (extract-cn-linear-eqn cn cycle-vars)))
               ;; if we can't extract a linear equation from one of
               ;; the cns, we can't solve the cycle with this cycle
               ;; solver: return nil immediately
               (when (null eqn)
             (return-from linear-eqn-cycle-solver nil))
               eqn)))
     (soln (solve-linear-eqns eqns))
     )
    (cond (soln
       ;; we have a soln: install calculated values in vars and return t
       (loop for var in cycle-vars do
         (setf (VAR-value var)
           (linear-eqn-soln-val soln var)))
       t)
      (t
       ;; no solution found: return nil
       nil))
    ))

;; takes a list of enforced cns, and unmarks all downstream enforced cns
;; that are marked with prop-mark (stopping the recursion when unmarked cns
;; are found).  All vars that are outputs of these cns are marked invalid.
(defun unmark-invalidate-downstream (cn prop-mark)
  (when (eql prop-mark (CN-mark cn))
    (setf (CN-mark cn) nil)
    (do-selected-method-output-vars (var cn)
      (setf (VAR-valid var) nil)
      (do-consuming-constraints (downstream-cn var)
    (unmark-invalidate-downstream downstream-cn prop-mark))
      )))

;; ***** constructing propagation plans *****

;; given a cn, pplan-add recursively travels downstream of the cn, marking
;; all cns with the given mark, and adds all marked cns to the specified
;; stack.  When this is done, the stack contains, in order the cns that
;; will have to be examined to propagate walkstrengths or var values.  Each
;; cn will only appear at most once on the stack (since they are marked
;; when they are added).  Note that it will be necessary to check for
;; cycles while examining the cns.  Note: further cns can be added as roots
;; of the propagation, simply by calling pplan-add again.  pplan will also
;; take vars, or lists and stacks of cns and vars.

(defun pplan-add (stack obj done-mark)
  (cond ((sb-constraint-p obj)
     (when (and (enforced obj)
            (not (eql done-mark (CN-mark obj))))
       ;; process unmarked, enforced constraint by marking it, collecting
       ;; downstream constraints, and pushing it on top of the pplan stack.
       (setf (CN-mark obj) done-mark)
       (do-selected-method-output-vars (out-var obj)
         (pplan-add stack out-var done-mark))
       (sb-stack-push stack obj))
     )
    ((sb-variable-p obj)
     ;; process variable by collecting downstream constraints rooted with
     ;; constraints directly consuming the variable
     (do-consuming-constraints (cn obj)
       (pplan-add stack cn done-mark))
     )
    ;; accept list of cns and vars
    ((null obj)
     nil)
    ((listp obj)
     (pplan-add stack (car obj) done-mark)
     (pplan-add stack (cdr obj) done-mark))
    ;; also accept stack of cns and vars
    ((sb-stack-p obj)
     (do-sb-stack-elts (elt obj)
       (pplan-add stack elt done-mark)))
    (t
     (cerror "cont" "pplan-add: bad object ~S" obj))
    ))

;; ***** extracting and executing plans *****

(defvar *extract-plan-stack* (sb-stack-create 100))

(defun extract-plan (root-cns)
  (let ((prop-mark (new-mark))
    (good-cns nil)
    (bad-cns nil)
    cn)
    ;; mark all cns we will be processing, and collect ordered pplan
    (sb-stack-clear *extract-plan-stack*)
    (pplan-add *extract-plan-stack* root-cns prop-mark)
    ;; scan through pplan
    (loop until (sb-stack-empty *extract-plan-stack*) do
      (setq cn (sb-stack-pop *extract-plan-stack*))
      (cond ((not (eql prop-mark (CN-mark cn)))
         ;; this cn has already been processed: ignore
         nil)
        ((any-immediate-upstream-cns-marked cn prop-mark)
         ;; Some of this cn's upstream cns have not been processed:
         ;; there must be a cycle.  Add cn to invalid cns list.
         (push cn bad-cns)
         ;; note: do _not_ unmark this cn: all cns
         ;; in the cycle, and downstream of it, will be added
         ;; to the bad list.
         )
        (t
         ;; all the upstream cns have been processed, so unmark this one
         ;; and add it to the beginning of the plan
         ;; (will reverse plan before returning)
         (setf (CN-mark cn) nil)
         (push cn good-cns)
         )))
    (create-valid-plan root-cns (nreverse good-cns) bad-cns)
    ))

;; a (plan-good-cns plan) is just a list of constraints, to be executed in
;; order
(defun execute-plan (plan)
  (cond ((sb-plan-valid plan)
     (loop for cn in (sb-plan-good-cns plan) do
           (execute-propagate-valid cn))
     )
    (t
     (cerror "noop" "trying to execute invalid plan ~S" plan))
    ))

;; ** plan invalidation **

(defun create-valid-plan (root-cns good-cns bad-cns)
  (let ((plan (make-sb-plan :root-cns root-cns
                :good-cns good-cns
                :bad-cns bad-cns
                :valid t)))
    (add-valid-plan-to-cns plan (sb-plan-good-cns plan))
    (add-valid-plan-to-cns plan (sb-plan-bad-cns plan))
    (add-valid-plan-to-cns plan (sb-plan-root-cns plan))
    plan))

(defun add-valid-plan-to-cns (plan cns)
  (loop for cn in cns
      do (set-sb-slot cn :valid-plans
              (adjoin plan (get-sb-slot cn :valid-plans)))))

(defun invalidate-plans-on-setting-method (cn new-mt)
  (invalidate-constraint-plans cn)
  (when new-mt
    (do-method-input-vars (var cn new-mt)
      (let ((input-cn (VAR-determined-by var)))
    (when input-cn
      (invalidate-constraint-plans input-cn))
    )))
  )

(defun invalidate-constraint-plans (invalid-cn)
  (let* ()
    (loop for plan in (get-sb-slot invalid-cn :valid-plans) do
      ;; (when (sb-plan-valid plan) (format t "~&invalidating plan ~S~%" plan))
      (setf (sb-plan-valid plan) nil)
      (remove-invalid-plan-from-other-cns plan (sb-plan-good-cns plan) invalid-cn)
      (remove-invalid-plan-from-other-cns plan (sb-plan-bad-cns plan) invalid-cn)
      (remove-invalid-plan-from-other-cns plan (sb-plan-root-cns plan) invalid-cn)
      )
    (set-sb-slot invalid-cn :valid-plans nil)
    ))

(defun remove-invalid-plan-from-other-cns (plan cns invalid-cn)
  (loop for cn in cns do
    (when (not (eql cn invalid-cn))
      (set-sb-slot cn :valid-plans
               (remove plan (get-sb-slot cn :valid-plans)))
      )))